home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1994 / MacHack 1994.toast / MacHack™94 / Talks & Papers / Timothy Knox / yerk 3.66 / System source / Base < prev    next >
Text File  |  1994-06-24  |  13KB  |  472 lines
  1. ( base  ==============================  June 12 84 )
  2. (  6/12/84  NDI Added DISK.SCR to front )
  3. (  8/15/84  CBD Added Select{ indexed case structure )
  4. ( 10/03/84  CBD Scon and other stuff )
  5. ( 10/08/84  CBD Added .h, .d, etc. )
  6. ( 10/12/84  CBD Added class error handling )
  7. ( 10/12/84  CBD Converted Variables to Values )
  8. ( 12/29/84  cbd Added resource string handling )
  9. ( 11/12/85  cdn Fixed nullOSstr; Msg# end with a CR )
  10. ( 12/20/85  cdn Made ascii sensitive to case )
  11. ( 12/12/85  cdn Corrected rDepth )
  12. (  2/21/86  cdn Changed file rewind to set EOF=0 in (save)
  13. (  6/18/86  cdn Added GetRes )
  14. (  6/26/86  cdn Added token )
  15. ( 10/09/86  cdn Modified next, for 2.0 nucleus )
  16. (  8/31/88    rfl changed extend to make it faster AND fixed >uc trap a054)
  17. (  7/10/90    rfl    modified getstring to return 0 0 if not found
  18. ( 12/24/90    rfl    changed the word BE to BI so that $be is valid.
  19. (  6/08/91  rfl    'type now works for upper and lower case
  20. ( 12/09/92    rfl    added switch to ?rdepth so that proc words don't have a problem if stack is
  21. (                  moved somewhere else in memory due to context switching
  22. (                  Actualy ?rdepth word moved to source Class
  23. (  5/01/93    rfl    added gestalt
  24. (  5/07/93    rfl    added asc>bin and bin>asc
  25. (  5/14/93    rfl    modified getstring to not open yerk.rsrc...error message if not found
  26. ( 11/29/93    rfl    modified patch word to understand colon defs with arguments and :code
  27. (                 definitions. Note that there is still no forward for :code defs., but
  28. (                 forward does work for named input parameters and local variables.
  29. (  1/01/94    rfl moved file related words to file source: file-install etc
  30. (  3/10/94    rfl    added patchL
  31. Decimal
  32.  
  33. ( Ignore rest-of-line; a comment )
  34. : \  R> Drop ;    \ Exits to word that called Interpret
  35. Immediate
  36.  
  37. \ Display contents of return stack
  38. : trace r0 rp@ (.stack) ;
  39.  
  40. \ Mac File/Record Interface
  41. 4 constant cLen    \ length of a CFA
  42.  
  43. 0 constant nullVal
  44. : nullOSstr ' nullVal +base ;
  45.  
  46. \ ( -- ^wordstring )  retrieve next word from input stream
  47. : @word BL word here ;
  48.  
  49. Create not ' 0= here 4- !
  50.  
  51. : 0,  0 , ;    \ compile an empty cell
  52.  
  53. \ ( -- n )  parse a number from the input stream
  54. : @val  @word number drop ;
  55.  
  56. \ state-smart single cfa compiler
  57. : 'c @pfa cfa  state IF Compile lit , THEN ; Immediate
  58.  
  59. \ Leave code address on stack of word in input stream
  60. : 'Code     @pfa cfa @ [Compile] Literal ; Immediate
  61. 'code quit constant colCode
  62.  
  63. \ make latest word unfindable
  64. : smudge latest 32 toggle ; Immediate
  65.  
  66. \ ( -- 4bytestring )  OS type literal; both upper and lowercase
  67. : 'type
  68.     pad 4 bl fill  tib in + bl enclose (lcWord) here count 4 min
  69.     pad swap cmove  pad @ [Compile] literal
  70. ; Immediate
  71.  
  72. \ true if error; false if no error
  73. : gestalt ( -- response 0 or negativeErr ) [compile] 'type
  74.         state
  75.         IF  compile (gestalt)
  76.         ELSE (gestalt)
  77.         THEN ; immediate
  78.  
  79. \ some Forth83 compatible words
  80. Create >Link '  4- here 4- !    \ ( cfa -- lfa )
  81. Create Link> '  4+ here 4- !    \ ( lfa -- cfa )
  82. Create >Body '  4+ here 4- !    \ ( cfa -- pfa )
  83. Create Body> ' cfa here 4- !    \ ( pfa -- cfa )
  84. : Name>  pfa cfa ;                \ ( nfa -- cfa )
  85. : >Name  4+ nfa ;                \ ( cfa -- nfa )
  86.  
  87. \ Compile an inline string at addr
  88. : str,   c@ 1+ align allot  ;
  89.  
  90. 0 variable buf255 252 allot    \ buffer for string operations
  91.  
  92. \ Convert a string to a Str255 at buf leaving its absolute addr
  93. \ ( addr len addr -- abs:str255 )
  94. : >str255    >R dup R c! R 1+ swap cmove R> +base ;
  95. : Str255     buf255 >str255 ;
  96.  
  97. \ ( b -- )
  98. : Abort"  ?Comp  Compile (Ab")  word"  Str, ;  Immediate
  99.  
  100. \ State-smart HEX literal word - $ 30
  101. : $ Base   >R hex  @val
  102.     [Compile] literal   R> Put base ; Immediate
  103.  
  104. : w @val state
  105.     IF Compile wLitw w, ELSE makeInt THEN ; Immediate
  106.  
  107. hex 
  108. create extend 2017 w, 48c0 w, 2e80 w, $ 4EEB w,  next w,
  109. decimal
  110.  
  111. \ Define state-smart inline string literal
  112. : (lit")  R> count 2dup + align >R ;    \ runTime handler
  113.  
  114. \ ( -- addr len )
  115. : " state
  116.     IF Compile (lit")  word" str,
  117.     ELSE  word" buf255 over c@ 1+ cmove
  118.         buf255 count
  119.     THEN
  120. ; Immediate
  121.  
  122. \ Multiple code field support - see JFAR V1 #1, p.55
  123. \ 10/18/84  CBD  Version 1
  124.  
  125. ( #cfas seq# [prefix] -- addr #cfas nuseq# )
  126. : DO..
  127.     dup 8 > IF  , THEN    \ compile pfa of prefix
  128.     1- 2dup - 4* w,  Here  rot rot        \ (CODEFIELD)
  129.     'code dojmp Here 10 allot 10 cmove    \ DODO,
  130.     [Compile]  ]>  ;
  131.  
  132. \ end a DO.. construct
  133. : ..End Compile ;s  [Compile] <[ ; Immediate
  134.  
  135. \ Get inline code and compile it
  136. : (,code)
  137.     R> dup w@ swap 2+ swap
  138.     2dup + >R  Here swap dup allot cmove ;
  139.  
  140. \ ( addr len -- )  open resource file for name
  141. : OpenResFile
  142.     >R >R word0 R> R> str255
  143.     $ a997 trap  i->l    \ call OpenResFile
  144.     -1 = abort" resource file open failed" ;
  145.  
  146. \ open the yerk system resource file
  147. : openNR  " yerk.rsrc" OpenResFile ;
  148.  
  149. openNR
  150.  
  151. \ ( -- ascii )  Leave ascii val of next char in stream
  152. : Ascii
  153.     tib in + bl enclose (LCword)
  154.     here 1+ c@ [Compile] literal
  155. ; Immediate
  156.  
  157. \ ( resID -- addr len) get the string with resource ID
  158. : getString
  159.     0 swap makeint $ a9ba trap    \ call getString
  160.     dup 0= IF ." GetString Failed" type abort THEN
  161.     >ptr count ;
  162.  
  163. \ ( strID -- )  print string and abort
  164. : die
  165.     ." Error# " dup . ascii : emit
  166.     getString type 5 beep abort ;
  167.  
  168. \ ( nfa -- )  print a name field, filter out garbage
  169. : .name
  170.     count $ 5f and dup 16 >
  171.     IF 2drop ." ??? "
  172.     ELSE type space
  173.     THEN ." ::" ;
  174.  
  175. \ ( b -- ) abort with string whose resID is at IP
  176. : (.rAbort)
  177.     w@(IP) swap
  178.     IF cr ." In " R> drop R cLen - @ >name .name die
  179.     ELSE drop
  180.     THEN ;
  181.  
  182. \ ( b -- ) abort and print resource string if true. use: ?error str#
  183. : ?Error  Compile (.rAbort) @val w, ; Immediate
  184.  
  185. \ ( -- )  print string whose resID is at IP
  186. : (.tStr)  w@(IP) getString type ;
  187.  
  188. \ ( -- )  print string for id# in stream
  189. : type#  Compile (.tStr) @val w, ; Immediate
  190.  
  191. \ ( -- )  print string whose resID is at IP
  192. : (.rStr)  w@(IP) ." Msg# " dup . ascii : emit getString type cr ;
  193.  
  194. \ ( -- )  print " Msg#" & string for id# in stream
  195. : msg#  Compile (.rStr) @val w, ; Immediate
  196.  
  197. \ build a dictionary header without a cfa
  198. : header   create -4 allot ;
  199.  
  200. : Build
  201.     ?error 169    \ not enough codefields
  202.     Compile header  Compile (,code)
  203.     dup 4* W,  0 DO , LOOP
  204. ; Immediate
  205.  
  206. : CodeFields dup ;
  207.  
  208. \  ================ Resources ===========
  209.  
  210. \ ( resID type -- handle )  GetRes support word
  211. : (GetRes)  0 swap rot makeInt $ a9a0 trap ;    \ call GetResource
  212.  
  213. \ ( resID : type -- handle )  Load the resource from the resource file chain
  214. : GetRes
  215.     [Compile] 'type
  216.     state IF Compile (GetRes)
  217.         ELSE (GetRes) THEN
  218. ; Immediate
  219.  
  220. \ Resource support - use: 'type TYPE 1 rsrc sam
  221. 1 codefields
  222.  
  223. \ ( -- ^res ) get the resource into memory
  224.     Do..  dup 4+ w@ swap @ (GetRes)
  225.         dup 0= ?error 170    \ getResource Failed
  226.         >ptr  ..End
  227.  
  228. : rsrc  Build  swap , w,  ..End
  229.  
  230. \ Force printing in hex or decimal
  231. ( n -- )
  232. : .H  base >R  hex     . R> Put base ;
  233. : .D  base >R  decimal . R> Put base ;
  234.  
  235. \ ( -- )  Goto threaded code  whose addr in next dict cell
  236. : (Jmp)  R> @ >R ;
  237.  
  238. \ Patch pfa at old  to exec new
  239. \  takes care of both colon code, local parameters, and code defs
  240. : (patch) \ { pfaOld pfaNew \ colNew -- } \ keep pfaOld and pfaNew on stack and use pick
  241.                                           \ colNew is temporarily put on return stack
  242.     dup cfa @ over =
  243.     IF dup 3 pick cfa !                         \ new word is a code definition, -1
  244.     ELSE dup cfa @ ' colp <> >r                \ be careful...there  may be other ids here
  245.         r                                    \ if new word is colon, set old as too
  246.         IF colCode  ELSE ' colp THEN 3 pick cfa !    \ else store colp def
  247.         'c (jmp) 3 pick r not IF 2+ THEN !        \ put (jmp) in right place
  248.         r not                                \ if new word has local parms
  249.         IF dup w@ 3 pick w! THEN                \ then set number of parms in old
  250.         dup r> not                        \ if new word has local parms
  251.         IF 2+ 3 pick  2+                        \   then store new pfa into old parm field
  252.         ELSE 3 pick                                \   else put it into normal position
  253.         THEN clen + !
  254.     THEN 2drop ;
  255.  
  256.  
  257. \ Patch a word to a newly defined word
  258. \ Use:  Patch oldWord newWord
  259. : Patch  @pfa @pfa (patch) ; Immediate
  260.  
  261. \ patch the named word with the latest definition
  262. : patchL @pfa latest pfa (patch) ; Immediate
  263.  
  264. \  Forward referencing support
  265. \ ( -- )  declare a new forward reference
  266. : Forward
  267.     <Builds  0, 0,
  268.     Does> cr  msg# 109   cLen -
  269.         nfa  .name  R .h  abort ;
  270.  
  271. : :F  @pfa Here [Compile] ]> ;
  272.  
  273. : ;F (patch) Compile ;s  [Compile]  <[  ; Immediate
  274.  
  275. \ define a Value - a multiple-cfa structure that responds to
  276. \ Put, ++ and its default action is a fetch
  277. : Value
  278.     Header  here 12 allot 'c base
  279.     swap 12 cmove , ;
  280.  
  281. \ a vect responds to Put, Get, and default action is execute
  282. : Vect
  283.     Header here 12 allot 'c vModel swap
  284.     12 cmove  , ;
  285.  
  286. \ ( -- #cells)
  287. : mDepth  m0  mp@ - 4 / ;
  288. : rDepth  r0  rp@ - 4 / 2- ;    \ 2- accounts for threading of rDepth & rp@
  289.  
  290. : errBeep  5 beep ;
  291.  
  292. \ ( ^obj -- )
  293. : .ClassName  cfa @ nfa .name ;
  294.  
  295. \ Error routine for objects prints class name first
  296. \ Only valid inside of a method.
  297. : (classErr")
  298.     w@(IP) swap
  299.     IF  cr  msg# 104
  300.         copym .className  copym .h space die
  301.     ELSE  drop  THEN ;
  302.  
  303. : classErr"  Compile (classerr") @val w, ; Immediate
  304.  
  305. -39 Constant EOF
  306.  
  307. \ pseudo-assembler macros
  308. : popD0        $ 201F w, ; Immediate    \ MOVE.L (A7)+,D0
  309. : popA0        $ 205F w, ; Immediate    \ MOVE.L (A7)+,A0
  310. : pushD0    $ 2F00 w, ; Immediate    \ MOVE.L D0,-(A7)
  311. : pushA0    $ 2F08 w, ; Immediate    \ MOVE.L A0,-(A7)
  312. : next,        $ 4EEB w,  next w, ; Immediate
  313.  
  314. \ Define these code words above the nucleus
  315. \ this allows getMtxt to Find them at run time on a sealed nucleus
  316. Create null next,
  317. Create bye $ a9f4 w,
  318.  
  319. \ ( abs:addr len -- )  map string to upper case
  320. Create >uc
  321.     popD0
  322.     popA0
  323.     $ a054 w,    \ call uprString
  324.     next,
  325.  
  326. \ primitive ascii to binary conversion
  327. hex
  328. create (asc>bin)    ( str255 -- n)
  329.     2057    w,        \ movea.l    (sp),a0
  330.     3f3c0001 ,        \ move.w    #1,-(sp)
  331.     7001     w,        \ moveq        #1,d0
  332.     a9ee     w,        \ call pack7
  333.     2e80     w,        \ move.l    d0,(sp)
  334. next,
  335.  
  336. : asc>bin ( addr len -- n) str255 (asc>bin) ;
  337.  
  338. \ string is put into pad
  339. hex
  340. create bin>asc        ( n -- addr len )
  341.     201f      w,            \ move.l    (sp)+,d0
  342.     207c w, pad ,        \ movea.l    YERK[pad],a0
  343.     d1cb     w,            \ adda.l    a3,a0
  344.     3f3c0000 ,            \ move.w    #0,-(sp)
  345.     a9ee      w,            \ _numToString
  346.     4280      w,            \ clr.l        d0
  347.     1018      w,            \ move.b    (a0)+,d0
  348.     91cb      w,            \ suba.l    a3,a0
  349.     2f08      w,            \ move.l    a0,-(sp)
  350.     2f00     w,            \ move.l    d0,-(sp)
  351. next,
  352. decimal
  353.  
  354. \ ==========  Various utility words needed  later
  355.  
  356. \ Become allows restarting at a given word, assuring that all stacks
  357. \ are empty.  This is necessary in menu handlers and other areas
  358. \ that could create indefinite nesting situations.
  359. 'c quit Vect becomeCFA
  360.  
  361. : Bi  sp! rp! mp!  becomeCfa quit ;
  362.  
  363. : (be)  R> @ put becomeCfa bi ;
  364.  
  365. \ use: Become newWord - compiles code to Be at runtime
  366. : Become
  367.     @pfa cfa State
  368.     IF  Compile (be) , ELSE put becomeCfa bi THEN
  369. ; Immediate
  370.  
  371. cLen CONSTANT CFALEN
  372. \ stack compiled list of values starting at IP
  373. : (lits)
  374.     R> dup w@  4* swap 2+ swap over +
  375.     dup   >R  swap
  376.     DO i@ 4 +LOOP ;
  377.  
  378. \ ( #lits -- #lits )  Compile header for list of literals if compile state
  379. : ,(lits)   state IF 'c (Lits) , dup W, THEN  ;
  380.  
  381. \ state-smart word to compile or stack a list of cfas
  382. \ ( #cfas -- )  pull words from stream and compile cfas
  383. : 'cfas
  384.     ,(lits) 0
  385.     DO  @pfa cfa  State IF , THEN LOOP
  386. ; Immediate
  387.  
  388. \ ( len -- )  Clear and allocate at here
  389. : Reserve   Here over erase allot ;
  390.  
  391. \ String constant leaves Addr Len at runtime
  392. : Scon
  393.     <Builds  word" Str,
  394.     Does>  Count ;
  395.  
  396. \ ( addr1 len1 addr2 len2 -- b )  String compare
  397. : S=
  398.     >R  Swap R>  Over =
  399.     IF  (s=)  ELSE 2drop drop 0 THEN ;
  400.  
  401. \ ( adr chr -- adrnext adr len )  Parser
  402. : parse
  403.     enclose
  404.     4 pick + 2swap >R R + rot R> -
  405. ;
  406.  
  407. \ CASE should be used for non-contiguous values.
  408. \ this is a modified  Eaker/Duncan model.
  409. \ ofBr takes branch at IP 1 nest back, and preserves val if
  410. \ branch taken, else it is dropped.
  411. : Case   ?Comp  csp !Csp  4 ; Immediate
  412.  
  413. \ ( val tst -- )  ofBr will take branch if 0 is on stack
  414. : (of) over = ofBr ;
  415.  
  416. \ ( val loTst hiTst -- )  Branch if not within inclusive range
  417. : (rof)   rot >R R >= swap R <= And R> swap  ofBr ;
  418.  
  419. : Of     4 ?Pairs Compile (of) Here 0, 5 ; Immediate
  420.  
  421. : rangeOf  4 ?Pairs Compile (rof) Here 0, 5 ; Immediate
  422.  
  423. : EndOf  5 ?Pairs Compile Branch Here 0,
  424.      swap 2 [Compile] THEN 4 ; Immediate
  425.  
  426. : EndCase  4 ?Pairs Compile drop
  427.     BEGIN  sp@  csp  = not
  428.     WHILE  2 [Compile] THEN
  429.     REPEAT   Put csp  ; Immediate
  430.  
  431. \ the Select structure should be used when dispatching execution
  432. \ on contiguous indices starting at 0.  It is smaller and faster
  433. \ than the equivalent CASE construct.
  434. \ An indexed CASE construct for compact, fast execution
  435. \ Runtime word for indexed case execution
  436.  
  437.  -1 Value CaseIndex
  438.  
  439. : (Select)
  440.     Abs R>  @ Dup 4+ >R  Swap  1+
  441.     4* Over Swap - Swap @ Max  @  >R ;
  442.  
  443. \ Begin an indexed case structure - see Forth Dimensions vII p.51
  444. : Select{
  445.     Compile (Select)  Here 0, 0  0 Put CaseIndex
  446.     [Compile]  <[
  447. ; Immediate
  448.  
  449. : Is{
  450.     ?Exec CaseIndex -
  451.     ?error 102
  452.     CaseIndex  1+ put caseIndex
  453.     240  [Compile] ]>
  454. ; Immediate
  455.  
  456. : }End
  457.     240 ?Pairs
  458.     Compile  ;S [Compile] <[  Here
  459. ; Immediate
  460.  
  461. : Default{
  462.     [Compile]  ]>
  463. ; Immediate
  464.  
  465. : }Select
  466.     [Compile] ]>   Compile  ;S  ,  Here  Pushm
  467.     BEGIN  Dup   WHILE  ,  REPEAT  Drop
  468.     Dup 4+ ,  Here Swap !  PopM  4-  ,
  469. ; Immediate
  470.  
  471. <" Args
  472.